← Index
NYTProf Performance Profile   
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 17:10:45 2013
Reported on Tue Oct 15 17:12:50 2013

Filename(eval 1046)[/usr/share/perl/5.10/CGI.pm:850]
StatementsExecuted 1 statements in 261µs
Eval Invoked At/usr/share/perl/5.10/CGI.pm line 850
Line State
ments
Time
on line
Calls Time
in subs
Code
1package CGI;
21261µs%SUBS = (
3
4'URL_ENCODED'=> <<'END_OF_FUNC',
5sub URL_ENCODED { 'application/x-www-form-urlencoded'; }
6END_OF_FUNC
7
8'MULTIPART' => <<'END_OF_FUNC',
9sub MULTIPART { 'multipart/form-data'; }
10END_OF_FUNC
11
12'SERVER_PUSH' => <<'END_OF_FUNC',
13sub SERVER_PUSH { 'multipart/x-mixed-replace;boundary="' . shift() . '"'; }
14END_OF_FUNC
15
16'new_MultipartBuffer' => <<'END_OF_FUNC',
17# Create a new multipart buffer
18sub new_MultipartBuffer {
19 my($self,$boundary,$length) = @_;
20 return MultipartBuffer->new($self,$boundary,$length);
21}
22END_OF_FUNC
23
24'read_from_client' => <<'END_OF_FUNC',
25# Read data from a file handle
26sub read_from_client {
27 my($self, $buff, $len, $offset) = @_;
28 local $^W=0; # prevent a warning
29 return $MOD_PERL
30 ? $self->r->read($$buff, $len, $offset)
31 : read(\*STDIN, $$buff, $len, $offset);
32}
33END_OF_FUNC
34
35'delete' => <<'END_OF_FUNC',
36#### Method: delete
37# Deletes the named parameter entirely.
38####
39sub delete {
40 my($self,@p) = self_or_default(@_);
41 my(@names) = rearrange([NAME],@p);
42 my @to_delete = ref($names[0]) eq 'ARRAY' ? @$names[0] : @names;
43 my %to_delete;
44 for my $name (@to_delete)
45 {
46 CORE::delete $self->{param}{$name};
47 CORE::delete $self->{'.fieldnames'}->{$name};
48 $to_delete{$name}++;
49 }
50 @{$self->{'.parameters'}}=grep { !exists($to_delete{$_}) } $self->param();
51 return;
52}
53END_OF_FUNC
54
55#### Method: import_names
56# Import all parameters into the given namespace.
57# Assumes namespace 'Q' if not specified
58####
59'import_names' => <<'END_OF_FUNC',
60sub import_names {
61 my($self,$namespace,$delete) = self_or_default(@_);
62 $namespace = 'Q' unless defined($namespace);
63 die "Can't import names into \"main\"\n" if \%{"${namespace}::"} == \%::;
64 if ($delete || $MOD_PERL || exists $ENV{'FCGI_ROLE'}) {
65 # can anyone find an easier way to do this?
66 for (keys %{"${namespace}::"}) {
67 local *symbol = "${namespace}::${_}";
68 undef $symbol;
69 undef @symbol;
70 undef %symbol;
71 }
72 }
73 my($param,@value,$var);
74 for $param ($self->param) {
75 # protect against silly names
76 ($var = $param)=~tr/a-zA-Z0-9_/_/c;
77 $var =~ s/^(?=\d)/_/;
78 local *symbol = "${namespace}::$var";
79 @value = $self->param($param);
80 @symbol = @value;
81 $symbol = $value[0];
82 }
83}
84END_OF_FUNC
85
86#### Method: keywords
87# Keywords acts a bit differently. Calling it in a list context
88# returns the list of keywords.
89# Calling it in a scalar context gives you the size of the list.
90####
91'keywords' => <<'END_OF_FUNC',
92sub keywords {
93 my($self,@values) = self_or_default(@_);
94 # If values is provided, then we set it.
95 $self->{param}{'keywords'}=[@values] if @values;
96 my(@result) = defined($self->{param}{'keywords'}) ? @{$self->{param}{'keywords'}} : ();
97 @result;
98}
99END_OF_FUNC
100
101# These are some tie() interfaces for compatibility
102# with Steve Brenner's cgi-lib.pl routines
103'Vars' => <<'END_OF_FUNC',
104sub Vars {
105 my $q = shift;
106 my %in;
107 tie(%in,CGI,$q);
108 return %in if wantarray;
109 return \%in;
110}
111END_OF_FUNC
112
113# These are some tie() interfaces for compatibility
114# with Steve Brenner's cgi-lib.pl routines
115'ReadParse' => <<'END_OF_FUNC',
116sub ReadParse {
117 local(*in);
118 if (@_) {
119 *in = $_[0];
120 } else {
121 my $pkg = caller();
122 *in=*{"${pkg}::in"};
123 }
124 tie(%in,CGI);
125 return scalar(keys %in);
126}
127END_OF_FUNC
128
129'PrintHeader' => <<'END_OF_FUNC',
130sub PrintHeader {
131 my($self) = self_or_default(@_);
132 return $self->header();
133}
134END_OF_FUNC
135
136'HtmlTop' => <<'END_OF_FUNC',
137sub HtmlTop {
138 my($self,@p) = self_or_default(@_);
139 return $self->start_html(@p);
140}
141END_OF_FUNC
142
143'HtmlBot' => <<'END_OF_FUNC',
144sub HtmlBot {
145 my($self,@p) = self_or_default(@_);
146 return $self->end_html(@p);
147}
148END_OF_FUNC
149
150'SplitParam' => <<'END_OF_FUNC',
151sub SplitParam {
152 my ($param) = @_;
153 my (@params) = split ("\0", $param);
154 return (wantarray ? @params : $params[0]);
155}
156END_OF_FUNC
157
158'MethGet' => <<'END_OF_FUNC',
159sub MethGet {
160 return request_method() eq 'GET';
161}
162END_OF_FUNC
163
164'MethPost' => <<'END_OF_FUNC',
165sub MethPost {
166 return request_method() eq 'POST';
167}
168END_OF_FUNC
169
170'TIEHASH' => <<'END_OF_FUNC',
171sub TIEHASH {
172 my $class = shift;
173 my $arg = $_[0];
174 if (ref($arg) && UNIVERSAL::isa($arg,'CGI')) {
175 return $arg;
176 }
177 return $Q ||= $class->new(@_);
178}
179END_OF_FUNC
180
181'STORE' => <<'END_OF_FUNC',
182sub STORE {
183 my $self = shift;
184 my $tag = shift;
185 my $vals = shift;
186 my @vals = index($vals,"\0")!=-1 ? split("\0",$vals) : $vals;
187 $self->param(-name=>$tag,-value=>\@vals);
188}
189END_OF_FUNC
190
191'FETCH' => <<'END_OF_FUNC',
192sub FETCH {
193 return $_[0] if $_[1] eq 'CGI';
194 return undef unless defined $_[0]->param($_[1]);
195 return join("\0",$_[0]->param($_[1]));
196}
197END_OF_FUNC
198
199'FIRSTKEY' => <<'END_OF_FUNC',
200sub FIRSTKEY {
201 $_[0]->{'.iterator'}=0;
202 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
203}
204END_OF_FUNC
205
206'NEXTKEY' => <<'END_OF_FUNC',
207sub NEXTKEY {
208 $_[0]->{'.parameters'}->[$_[0]->{'.iterator'}++];
209}
210END_OF_FUNC
211
212'EXISTS' => <<'END_OF_FUNC',
213sub EXISTS {
214 exists $_[0]->{param}{$_[1]};
215}
216END_OF_FUNC
217
218'DELETE' => <<'END_OF_FUNC',
219sub DELETE {
220 $_[0]->delete($_[1]);
221}
222END_OF_FUNC
223
224'CLEAR' => <<'END_OF_FUNC',
225sub CLEAR {
226 %{$_[0]}=();
227}
228####
229END_OF_FUNC
230
231####
232# Append a new value to an existing query
233####
234'append' => <<'EOF',
235sub append {
236 my($self,@p) = self_or_default(@_);
237 my($name,$value) = rearrange([NAME,[VALUE,VALUES]],@p);
238 my(@values) = defined($value) ? (ref($value) ? @{$value} : $value) : ();
239 if (@values) {
240 $self->add_parameter($name);
241 push(@{$self->{param}{$name}},@values);
242 }
243 return $self->param($name);
244}
245EOF
246
247#### Method: delete_all
248# Delete all parameters
249####
250'delete_all' => <<'EOF',
251sub delete_all {
252 my($self) = self_or_default(@_);
253 my @param = $self->param();
254 $self->delete(@param);
255}
256EOF
257
258'Delete' => <<'EOF',
259sub Delete {
260 my($self,@p) = self_or_default(@_);
261 $self->delete(@p);
262}
263EOF
264
265'Delete_all' => <<'EOF',
266sub Delete_all {
267 my($self,@p) = self_or_default(@_);
268 $self->delete_all(@p);
269}
270EOF
271
272#### Method: autoescape
273# If you want to turn off the autoescaping features,
274# call this method with undef as the argument
275'autoEscape' => <<'END_OF_FUNC',
276sub autoEscape {
277 my($self,$escape) = self_or_default(@_);
278 my $d = $self->{'escape'};
279 $self->{'escape'} = $escape;
280 $d;
281}
282END_OF_FUNC
283
284
285#### Method: version
286# Return the current version
287####
288'version' => <<'END_OF_FUNC',
289sub version {
290 return $VERSION;
291}
292END_OF_FUNC
293
294#### Method: url_param
295# Return a parameter in the QUERY_STRING, regardless of
296# whether this was a POST or a GET
297####
298'url_param' => <<'END_OF_FUNC',
299sub url_param {
300 my ($self,@p) = self_or_default(@_);
301 my $name = shift(@p);
302 return undef unless exists($ENV{QUERY_STRING});
303 unless (exists($self->{'.url_param'})) {
304 $self->{'.url_param'}={}; # empty hash
305 if ($ENV{QUERY_STRING} =~ /=/) {
306 my(@pairs) = split(/[&;]/,$ENV{QUERY_STRING});
307 my($param,$value);
308 for (@pairs) {
309 ($param,$value) = split('=',$_,2);
310 $param = unescape($param);
311 $value = unescape($value);
312 push(@{$self->{'.url_param'}->{$param}},$value);
313 }
314 } else {
315 $self->{'.url_param'}->{'keywords'} = [$self->parse_keywordlist($ENV{QUERY_STRING})];
316 }
317 }
318 return keys %{$self->{'.url_param'}} unless defined($name);
319 return () unless $self->{'.url_param'}->{$name};
320 return wantarray ? @{$self->{'.url_param'}->{$name}}
321 : $self->{'.url_param'}->{$name}->[0];
322}
323END_OF_FUNC
324
325#### Method: Dump
326# Returns a string in which all the known parameter/value
327# pairs are represented as nested lists, mainly for the purposes
328# of debugging.
329####
330'Dump' => <<'END_OF_FUNC',
331sub Dump {
332 my($self) = self_or_default(@_);
333 my($param,$value,@result);
334 return '<ul></ul>' unless $self->param;
335 push(@result,"<ul>");
336 for $param ($self->param) {
337 my($name)=$self->escapeHTML($param);
338 push(@result,"<li><strong>$param</strong></li>");
339 push(@result,"<ul>");
340 for $value ($self->param($param)) {
341 $value = $self->escapeHTML($value);
342 $value =~ s/\n/<br \/>\n/g;
343 push(@result,"<li>$value</li>");
344 }
345 push(@result,"</ul>");
346 }
347 push(@result,"</ul>");
348 return join("\n",@result);
349}
350END_OF_FUNC
351
352#### Method as_string
353#
354# synonym for "dump"
355####
356'as_string' => <<'END_OF_FUNC',
357sub as_string {
358 &Dump(@_);
359}
360END_OF_FUNC
361
362#### Method: save
363# Write values out to a filehandle in such a way that they can
364# be reinitialized by the filehandle form of the new() method
365####
366'save' => <<'END_OF_FUNC',
367sub save {
368 my($self,$filehandle) = self_or_default(@_);
369 $filehandle = to_filehandle($filehandle);
370 my($param);
371 local($,) = ''; # set print field separator back to a sane value
372 local($\) = ''; # set output line separator to a sane value
373 for $param ($self->param) {
374 my($escaped_param) = escape($param);
375 my($value);
376 for $value ($self->param($param)) {
377 print $filehandle "$escaped_param=",escape("$value"),"\n";
378 }
379 }
380 for (keys %{$self->{'.fieldnames'}}) {
381 print $filehandle ".cgifields=",escape("$_"),"\n";
382 }
383 print $filehandle "=\n"; # end of record
384}
385END_OF_FUNC
386
387
388#### Method: save_parameters
389# An alias for save() that is a better name for exportation.
390# Only intended to be used with the function (non-OO) interface.
391####
392'save_parameters' => <<'END_OF_FUNC',
393sub save_parameters {
394 my $fh = shift;
395 return save(to_filehandle($fh));
396}
397END_OF_FUNC
398
399#### Method: restore_parameters
400# A way to restore CGI parameters from an initializer.
401# Only intended to be used with the function (non-OO) interface.
402####
403'restore_parameters' => <<'END_OF_FUNC',
404sub restore_parameters {
405 $Q = $CGI::DefaultClass->new(@_);
406}
407END_OF_FUNC
408
409#### Method: multipart_init
410# Return a Content-Type: style header for server-push
411# This has to be NPH on most web servers, and it is advisable to set $| = 1
412#
413# Many thanks to Ed Jordan <ed@fidalgo.net> for this
414# contribution, updated by Andrew Benham (adsb@bigfoot.com)
415####
416'multipart_init' => <<'END_OF_FUNC',
417sub multipart_init {
418 my($self,@p) = self_or_default(@_);
419 my($boundary,@other) = rearrange_header([BOUNDARY],@p);
420 if (!$boundary) {
421 $boundary = '------- =_';
422 my @chrs = ('0'..'9', 'A'..'Z', 'a'..'z');
423 for (1..17) {
424 $boundary .= $chrs[rand(scalar @chrs)];
425 }
426 }
427
428 $self->{'separator'} = "$CRLF--$boundary$CRLF";
429 $self->{'final_separator'} = "$CRLF--$boundary--$CRLF";
430 $type = SERVER_PUSH($boundary);
431 return $self->header(
432 -nph => 0,
433 -type => $type,
434 (map { split "=", $_, 2 } @other),
435 ) . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $self->multipart_end;
436}
437END_OF_FUNC
438
439
440#### Method: multipart_start
441# Return a Content-Type: style header for server-push, start of section
442#
443# Many thanks to Ed Jordan <ed@fidalgo.net> for this
444# contribution, updated by Andrew Benham (adsb@bigfoot.com)
445####
446'multipart_start' => <<'END_OF_FUNC',
447sub multipart_start {
448 my(@header);
449 my($self,@p) = self_or_default(@_);
450 my($type,@other) = rearrange([TYPE],@p);
451 $type = $type || 'text/html';
452 push(@header,"Content-Type: $type");
453
454 # rearrange() was designed for the HTML portion, so we
455 # need to fix it up a little.
456 for (@other) {
457 # Don't use \s because of perl bug 21951
458 next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/;
459 ($_ = $header) =~ s/^(\w)(.*)/$1 . lc ($2) . ': '.$self->unescapeHTML($value)/e;
460 }
461 push(@header,@other);
462 my $header = join($CRLF,@header)."${CRLF}${CRLF}";
463 return $header;
464}
465END_OF_FUNC
466
467
468#### Method: multipart_end
469# Return a MIME boundary separator for server-push, end of section
470#
471# Many thanks to Ed Jordan <ed@fidalgo.net> for this
472# contribution
473####
474'multipart_end' => <<'END_OF_FUNC',
475sub multipart_end {
476 my($self,@p) = self_or_default(@_);
477 return $self->{'separator'};
478}
479END_OF_FUNC
480
481
482#### Method: multipart_final
483# Return a MIME boundary separator for server-push, end of all sections
484#
485# Contributed by Andrew Benham (adsb@bigfoot.com)
486####
487'multipart_final' => <<'END_OF_FUNC',
488sub multipart_final {
489 my($self,@p) = self_or_default(@_);
490 return $self->{'final_separator'} . "WARNING: YOUR BROWSER DOESN'T SUPPORT THIS SERVER-PUSH TECHNOLOGY." . $CRLF;
491}
492END_OF_FUNC
493
494
495#### Method: header
496# Return a Content-Type: style header
497#
498####
499'header' => <<'END_OF_FUNC',
500sub header {
501 my($self,@p) = self_or_default(@_);
502 my(@header);
503
504 return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE;
505
506 my($type,$status,$cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) =
507 rearrange([['TYPE','CONTENT_TYPE','CONTENT-TYPE'],
508 'STATUS',['COOKIE','COOKIES'],'TARGET',
509 'EXPIRES','NPH','CHARSET',
510 'ATTACHMENT','P3P'],@p);
511
512 # Since $cookie and $p3p may be array references,
513 # we must stringify them before CR escaping is done.
514 my @cookie;
515 for (ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie) {
516 my $cs = UNIVERSAL::isa($_,'CGI::Cookie') ? $_->as_string : $_;
517 push(@cookie,$cs) if defined $cs and $cs ne '';
518 }
519 $p3p = join ' ',@$p3p if ref($p3p) eq 'ARRAY';
520
521 # CR escaping for values, per RFC 822
522 for my $header ($type,$status,@cookie,$target,$expires,$nph,$charset,$attachment,$p3p,@other) {
523 if (defined $header) {
524 # From RFC 822:
525 # Unfolding is accomplished by regarding CRLF immediately
526 # followed by a LWSP-char as equivalent to the LWSP-char.
527 $header =~ s/$CRLF(\s)/$1/g;
528
529 # All other uses of newlines are invalid input.
530 if ($header =~ m/$CRLF|\015|\012/) {
531 # shorten very long values in the diagnostic
532 $header = substr($header,0,72).'...' if (length $header > 72);
533 die "Invalid header value contains a newline not followed by whitespace: $header";
534 }
535 }
536 }
537
538 $nph ||= $NPH;
539
540 $type ||= 'text/html' unless defined($type);
541
542 if (defined $charset) {
543 $self->charset($charset);
544 } else {
545 $charset = $self->charset if $type =~ /^text\//;
546 }
547 $charset ||= '';
548
549 # rearrange() was designed for the HTML portion, so we
550 # need to fix it up a little.
551 for (@other) {
552 # Don't use \s because of perl bug 21951
553 next unless my($header,$value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/s;
554 ($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
555 }
556
557 $type .= "; charset=$charset"
558 if $type ne ''
559 and $type !~ /\bcharset\b/
560 and defined $charset
561 and $charset ne '';
562
563 # Maybe future compatibility. Maybe not.
564 my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
565 push(@header,$protocol . ' ' . ($status || '200 OK')) if $nph;
566 push(@header,"Server: " . &server_software()) if $nph;
567
568 push(@header,"Status: $status") if $status;
569 push(@header,"Window-Target: $target") if $target;
570 push(@header,"P3P: policyref=\"/w3c/p3p.xml\", CP=\"$p3p\"") if $p3p;
571 # push all the cookies -- there may be several
572 push(@header,map {"Set-Cookie: $_"} @cookie);
573 # if the user indicates an expiration time, then we need
574 # both an Expires and a Date header (so that the browser is
575 # uses OUR clock)
576 push(@header,"Expires: " . expires($expires,'http'))
577 if $expires;
578 push(@header,"Date: " . expires(0,'http')) if $expires || $cookie || $nph;
579 push(@header,"Pragma: no-cache") if $self->cache();
580 push(@header,"Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
581 push(@header,map {ucfirst $_} @other);
582 push(@header,"Content-Type: $type") if $type ne '';
583 my $header = join($CRLF,@header)."${CRLF}${CRLF}";
584 if (($MOD_PERL >= 1) && !$nph) {
585 $self->r->send_cgi_header($header);
586 return '';
587 }
588 return $header;
589}
590END_OF_FUNC
591
592
593#### Method: cache
594# Control whether header() will produce the no-cache
595# Pragma directive.
596####
597'cache' => <<'END_OF_FUNC',
598sub cache {
599 my($self,$new_value) = self_or_default(@_);
600 $new_value = '' unless $new_value;
601 if ($new_value ne '') {
602 $self->{'cache'} = $new_value;
603 }
604 return $self->{'cache'};
605}
606END_OF_FUNC
607
608
609#### Method: redirect
610# Return a Location: style header
611#
612####
613'redirect' => <<'END_OF_FUNC',
614sub redirect {
615 my($self,@p) = self_or_default(@_);
616 my($url,$target,$status,$cookie,$nph,@other) =
617 rearrange([[LOCATION,URI,URL],TARGET,STATUS,['COOKIE','COOKIES'],NPH],@p);
618 $status = '302 Found' unless defined $status;
619 $url ||= $self->self_url;
620 my(@o);
621 for (@other) { tr/\"//d; push(@o,split("=",$_,2)); }
622 unshift(@o,
623 '-Status' => $status,
624 '-Location'=> $url,
625 '-nph' => $nph);
626 unshift(@o,'-Target'=>$target) if $target;
627 unshift(@o,'-Type'=>'');
628 my @unescaped;
629 unshift(@unescaped,'-Cookie'=>$cookie) if $cookie;
630 return $self->header((map {$self->unescapeHTML($_)} @o),@unescaped);
631}
632END_OF_FUNC
633
634
635#### Method: start_html
636# Canned HTML header
637#
638# Parameters:
639# $title -> (optional) The title for this HTML document (-title)
640# $author -> (optional) e-mail address of the author (-author)
641# $base -> (optional) if set to true, will enter the BASE address of this document
642# for resolving relative references (-base)
643# $xbase -> (optional) alternative base at some remote location (-xbase)
644# $target -> (optional) target window to load all links into (-target)
645# $script -> (option) Javascript code (-script)
646# $no_script -> (option) Javascript <noscript> tag (-noscript)
647# $meta -> (optional) Meta information tags
648# $head -> (optional) any other elements you'd like to incorporate into the <head> tag
649# (a scalar or array ref)
650# $style -> (optional) reference to an external style sheet
651# @other -> (optional) any other named parameters you'd like to incorporate into
652# the <body> tag.
653####
654'start_html' => <<'END_OF_FUNC',
655sub start_html {
656 my($self,@p) = &self_or_default(@_);
657 my($title,$author,$base,$xbase,$script,$noscript,
658 $target,$meta,$head,$style,$dtd,$lang,$encoding,$declare_xml,@other) =
659 rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,
660 META,HEAD,STYLE,DTD,LANG,ENCODING,DECLARE_XML],@p);
661
662 $self->element_id(0);
663 $self->element_tab(0);
664
665 $encoding = lc($self->charset) unless defined $encoding;
666
667 # Need to sort out the DTD before it's okay to call escapeHTML().
668 my(@result,$xml_dtd);
669 if ($dtd) {
670 if (defined(ref($dtd)) and (ref($dtd) eq 'ARRAY')) {
671 $dtd = $DEFAULT_DTD unless $dtd->[0] =~ m|^-//|;
672 } else {
673 $dtd = $DEFAULT_DTD unless $dtd =~ m|^-//|;
674 }
675 } else {
676 $dtd = $XHTML ? XHTML_DTD : $DEFAULT_DTD;
677 }
678
679 $xml_dtd++ if ref($dtd) eq 'ARRAY' && $dtd->[0] =~ /\bXHTML\b/i;
680 $xml_dtd++ if ref($dtd) eq '' && $dtd =~ /\bXHTML\b/i;
681 push @result,qq(<?xml version="1.0" encoding="$encoding"?>) if $xml_dtd && $declare_xml;
682
683 if (ref($dtd) && ref($dtd) eq 'ARRAY') {
684 push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd->[0]"\n\t "$dtd->[1]">));
685 $DTD_PUBLIC_IDENTIFIER = $dtd->[0];
686 } else {
687 push(@result,qq(<!DOCTYPE html\n\tPUBLIC "$dtd">));
688 $DTD_PUBLIC_IDENTIFIER = $dtd;
689 }
690
691 # Now that we know whether we're using the HTML 3.2 DTD or not, it's okay to
692 # call escapeHTML(). Strangely enough, the title needs to be escaped as
693 # HTML while the author needs to be escaped as a URL.
694 $title = $self->escapeHTML($title || 'Untitled Document');
695 $author = $self->escape($author);
696
697 if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML (2\.0|3\.2)/i) {
698 $lang = "" unless defined $lang;
699 $XHTML = 0;
700 }
701 else {
702 $lang = 'en-US' unless defined $lang;
703 }
704
705 my $lang_bits = $lang ne '' ? qq( lang="$lang" xml:lang="$lang") : '';
706 my $meta_bits = qq(<meta http-equiv="Content-Type" content="text/html; charset=$encoding" />)
707 if $XHTML && $encoding && !$declare_xml;
708
709 push(@result,$XHTML ? qq(<html xmlns="http://www.w3.org/1999/xhtml"$lang_bits>\n<head>\n<title>$title</title>)
710 : ($lang ? qq(<html lang="$lang">) : "<html>")
711 . "<head><title>$title</title>");
712 if (defined $author) {
713 push(@result,$XHTML ? "<link rev=\"made\" href=\"mailto:$author\" />"
714 : "<link rev=\"made\" href=\"mailto:$author\">");
715 }
716
717 if ($base || $xbase || $target) {
718 my $href = $xbase || $self->url('-path'=>1);
719 my $t = $target ? qq/ target="$target"/ : '';
720 push(@result,$XHTML ? qq(<base href="$href"$t />) : qq(<base href="$href"$t>));
721 }
722
723 if ($meta && ref($meta) && (ref($meta) eq 'HASH')) {
724 for (keys %$meta) { push(@result,$XHTML ? qq(<meta name="$_" content="$meta->{$_}" />)
725 : qq(<meta name="$_" content="$meta->{$_}">)); }
726 }
727
728 my $meta_bits_set = 0;
729 if( $head ) {
730 if( ref $head ) {
731 push @result, @$head;
732 $meta_bits_set = 1 if grep { /http-equiv=["']Content-Type/i }@$head;
733 }
734 else {
735 push @result, $head;
736 $meta_bits_set = 1 if $head =~ /http-equiv=["']Content-Type/i;
737 }
738 }
739
740 # handle the infrequently-used -style and -script parameters
741 push(@result,$self->_style($style)) if defined $style;
742 push(@result,$self->_script($script)) if defined $script;
743 push(@result,$meta_bits) if defined $meta_bits and !$meta_bits_set;
744
745 # handle -noscript parameter
746 push(@result,<<END) if $noscript;
747<noscript>
748$noscript
749</noscript>
750END
751 ;
752 my($other) = @other ? " @other" : '';
753 push(@result,"</head>\n<body$other>\n");
754 return join("\n",@result);
755}
756END_OF_FUNC
757
758### Method: _style
759# internal method for generating a CSS style section
760####
761'_style' => <<'END_OF_FUNC',
762sub _style {
763 my ($self,$style) = @_;
764 my (@result);
765
766 my $type = 'text/css';
767 my $rel = 'stylesheet';
768
769
770 my $cdata_start = $XHTML ? "\n<!--/* <![CDATA[ */" : "\n<!-- ";
771 my $cdata_end = $XHTML ? "\n/* ]]> */-->\n" : " -->\n";
772
773 my @s = ref($style) eq 'ARRAY' ? @$style : $style;
774 my $other = '';
775
776 for my $s (@s) {
777 if (ref($s)) {
778 my($src,$code,$verbatim,$stype,$alternate,$foo,@other) =
779 rearrange([qw(SRC CODE VERBATIM TYPE ALTERNATE FOO)],
780 ('-foo'=>'bar',
781 ref($s) eq 'ARRAY' ? @$s : %$s));
782 my $type = defined $stype ? $stype : 'text/css';
783 my $rel = $alternate ? 'alternate stylesheet' : 'stylesheet';
784 $other = "@other" if @other;
785
786 if (ref($src) eq "ARRAY") # Check to see if the $src variable is an array reference
787 { # If it is, push a LINK tag for each one
788 for $src (@$src)
789 {
790 push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
791 : qq(<link rel="$rel" type="$type" href="$src"$other>)) if $src;
792 }
793 }
794 else
795 { # Otherwise, push the single -src, if it exists.
796 push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
797 : qq(<link rel="$rel" type="$type" href="$src"$other>)
798 ) if $src;
799 }
800 if ($verbatim) {
801 my @v = ref($verbatim) eq 'ARRAY' ? @$verbatim : $verbatim;
802 push(@result, "<style type=\"text/css\">\n$_\n</style>") for @v;
803 }
804 my @c = ref($code) eq 'ARRAY' ? @$code : $code if $code;
805 push(@result,style({'type'=>$type},"$cdata_start\n$_\n$cdata_end")) for @c;
806
807 } else {
808 my $src = $s;
809 push(@result,$XHTML ? qq(<link rel="$rel" type="$type" href="$src" $other/>)
810 : qq(<link rel="$rel" type="$type" href="$src"$other>));
811 }
812 }
813 @result;
814}
815END_OF_FUNC
816
817'_script' => <<'END_OF_FUNC',
818sub _script {
819 my ($self,$script) = @_;
820 my (@result);
821
822 my (@scripts) = ref($script) eq 'ARRAY' ? @$script : ($script);
823 for $script (@scripts) {
824 my($src,$code,$language);
825 if (ref($script)) { # script is a hash
826 ($src,$code,$type) =
827 rearrange(['SRC','CODE',['LANGUAGE','TYPE']],
828 '-foo'=>'bar', # a trick to allow the '-' to be omitted
829 ref($script) eq 'ARRAY' ? @$script : %$script);
830 $type ||= 'text/javascript';
831 unless ($type =~ m!\w+/\w+!) {
832 $type =~ s/[\d.]+$//;
833 $type = "text/$type";
834 }
835 } else {
836 ($src,$code,$type) = ('',$script, 'text/javascript');
837 }
838
839 my $comment = '//'; # javascript by default
840 $comment = '#' if $type=~/perl|tcl/i;
841 $comment = "'" if $type=~/vbscript/i;
842
843 my ($cdata_start,$cdata_end);
844 if ($XHTML) {
845 $cdata_start = "$comment<![CDATA[\n";
846 $cdata_end .= "\n$comment]]>";
847 } else {
848 $cdata_start = "\n<!-- Hide script\n";
849 $cdata_end = $comment;
850 $cdata_end .= " End script hiding -->\n";
851 }
852 my(@satts);
853 push(@satts,'src'=>$src) if $src;
854 push(@satts,'type'=>$type);
855 $code = $cdata_start . $code . $cdata_end if defined $code;
856 push(@result,$self->script({@satts},$code || ''));
857 }
858 @result;
859}
860END_OF_FUNC
861
862#### Method: end_html
863# End an HTML document.
864# Trivial method for completeness. Just returns "</body>"
865####
866'end_html' => <<'END_OF_FUNC',
867sub end_html {
868 return "\n</body>\n</html>";
869}
870END_OF_FUNC
871
872
873################################
874# METHODS USED IN BUILDING FORMS
875################################
876
877#### Method: isindex
878# Just prints out the isindex tag.
879# Parameters:
880# $action -> optional URL of script to run
881# Returns:
882# A string containing a <isindex> tag
883'isindex' => <<'END_OF_FUNC',
884sub isindex {
885 my($self,@p) = self_or_default(@_);
886 my($action,@other) = rearrange([ACTION],@p);
887 $action = qq/ action="$action"/ if $action;
888 my($other) = @other ? " @other" : '';
889 return $XHTML ? "<isindex$action$other />" : "<isindex$action$other>";
890}
891END_OF_FUNC
892
893
894#### Method: startform
895# Start a form
896# Parameters:
897# $method -> optional submission method to use (GET or POST)
898# $action -> optional URL of script to run
899# $enctype ->encoding to use (URL_ENCODED or MULTIPART)
900'startform' => <<'END_OF_FUNC',
901sub startform {
902 my($self,@p) = self_or_default(@_);
903
904 my($method,$action,$enctype,@other) =
905 rearrange([METHOD,ACTION,ENCTYPE],@p);
906
907 $method = $self->escapeHTML(lc($method || 'post'));
908 $enctype = $self->escapeHTML($enctype || &URL_ENCODED);
909 if (defined $action) {
910 $action = $self->escapeHTML($action);
911 }
912 else {
913 $action = $self->escapeHTML($self->request_uri || $self->self_url);
914 }
915 $action = qq(action="$action");
916 my($other) = @other ? " @other" : '';
917 $self->{'.parametersToAdd'}={};
918 return qq/<form method="$method" $action enctype="$enctype"$other>\n/;
919}
920END_OF_FUNC
921
922
923#### Method: start_form
924# synonym for startform
925'start_form' => <<'END_OF_FUNC',
926sub start_form {
927 $XHTML ? &start_multipart_form : &startform;
928}
929END_OF_FUNC
930
931'end_multipart_form' => <<'END_OF_FUNC',
932sub end_multipart_form {
933 &endform;
934}
935END_OF_FUNC
936
937#### Method: start_multipart_form
938# synonym for startform
939'start_multipart_form' => <<'END_OF_FUNC',
940sub start_multipart_form {
941 my($self,@p) = self_or_default(@_);
942 if (defined($p[0]) && substr($p[0],0,1) eq '-') {
943 return $self->startform(-enctype=>&MULTIPART,@p);
944 } else {
945 my($method,$action,@other) =
946 rearrange([METHOD,ACTION],@p);
947 return $self->startform($method,$action,&MULTIPART,@other);
948 }
949}
950END_OF_FUNC
951
952
953#### Method: endform
954# End a form
955'endform' => <<'END_OF_FUNC',
956sub endform {
957 my($self,@p) = self_or_default(@_);
958 if ( $NOSTICKY ) {
959 return wantarray ? ("</form>") : "\n</form>";
960 } else {
961 if (my @fields = $self->get_fields) {
962 return wantarray ? ("<div>",@fields,"</div>","</form>")
963 : "<div>".(join '',@fields)."</div>\n</form>";
964 } else {
965 return "</form>";
966 }
967 }
968}
969END_OF_FUNC
970
971
972'_textfield' => <<'END_OF_FUNC',
973sub _textfield {
974 my($self,$tag,@p) = self_or_default(@_);
975 my($name,$default,$size,$maxlength,$override,$tabindex,@other) =
976 rearrange([NAME,[DEFAULT,VALUE,VALUES],SIZE,MAXLENGTH,[OVERRIDE,FORCE],TABINDEX],@p);
977
978 my $current = $override ? $default :
979 (defined($self->param($name)) ? $self->param($name) : $default);
980
981 $current = defined($current) ? $self->escapeHTML($current,1) : '';
982 $name = defined($name) ? $self->escapeHTML($name) : '';
983 my($s) = defined($size) ? qq/ size="$size"/ : '';
984 my($m) = defined($maxlength) ? qq/ maxlength="$maxlength"/ : '';
985 my($other) = @other ? " @other" : '';
986 # this entered at cristy's request to fix problems with file upload fields
987 # and WebTV -- not sure it won't break stuff
988 my($value) = $current ne '' ? qq(value="$current") : '';
989 $tabindex = $self->element_tab($tabindex);
990 return $XHTML ? qq(<input type="$tag" name="$name" $tabindex$value$s$m$other />)
991 : qq(<input type="$tag" name="$name" $value$s$m$other>);
992}
993END_OF_FUNC
994
995#### Method: textfield
996# Parameters:
997# $name -> Name of the text field
998# $default -> Optional default value of the field if not
999# already defined.
1000# $size -> Optional width of field in characaters.
1001# $maxlength -> Optional maximum number of characters.
1002# Returns:
1003# A string containing a <input type="text"> field
1004#
1005'textfield' => <<'END_OF_FUNC',
1006sub textfield {
1007 my($self,@p) = self_or_default(@_);
1008 $self->_textfield('text',@p);
1009}
1010END_OF_FUNC
1011
1012
1013#### Method: filefield
1014# Parameters:
1015# $name -> Name of the file upload field
1016# $size -> Optional width of field in characaters.
1017# $maxlength -> Optional maximum number of characters.
1018# Returns:
1019# A string containing a <input type="file"> field
1020#
1021'filefield' => <<'END_OF_FUNC',
1022sub filefield {
1023 my($self,@p) = self_or_default(@_);
1024 $self->_textfield('file',@p);
1025}
1026END_OF_FUNC
1027
1028
1029#### Method: password
1030# Create a "secret password" entry field
1031# Parameters:
1032# $name -> Name of the field
1033# $default -> Optional default value of the field if not
1034# already defined.
1035# $size -> Optional width of field in characters.
1036# $maxlength -> Optional maximum characters that can be entered.
1037# Returns:
1038# A string containing a <input type="password"> field
1039#
1040'password_field' => <<'END_OF_FUNC',
1041sub password_field {
1042 my ($self,@p) = self_or_default(@_);
1043 $self->_textfield('password',@p);
1044}
1045END_OF_FUNC
1046
1047#### Method: textarea
1048# Parameters:
1049# $name -> Name of the text field
1050# $default -> Optional default value of the field if not
1051# already defined.
1052# $rows -> Optional number of rows in text area
1053# $columns -> Optional number of columns in text area
1054# Returns:
1055# A string containing a <textarea></textarea> tag
1056#
1057'textarea' => <<'END_OF_FUNC',
1058sub textarea {
1059 my($self,@p) = self_or_default(@_);
1060 my($name,$default,$rows,$cols,$override,$tabindex,@other) =
1061 rearrange([NAME,[DEFAULT,VALUE],ROWS,[COLS,COLUMNS],[OVERRIDE,FORCE],TABINDEX],@p);
1062
1063 my($current)= $override ? $default :
1064 (defined($self->param($name)) ? $self->param($name) : $default);
1065
1066 $name = defined($name) ? $self->escapeHTML($name) : '';
1067 $current = defined($current) ? $self->escapeHTML($current) : '';
1068 my($r) = $rows ? qq/ rows="$rows"/ : '';
1069 my($c) = $cols ? qq/ cols="$cols"/ : '';
1070 my($other) = @other ? " @other" : '';
1071 $tabindex = $self->element_tab($tabindex);
1072 return qq{<textarea name="$name" $tabindex$r$c$other>$current</textarea>};
1073}
1074END_OF_FUNC
1075
1076
1077#### Method: button
1078# Create a javascript button.
1079# Parameters:
1080# $name -> (optional) Name for the button. (-name)
1081# $value -> (optional) Value of the button when selected (and visible name) (-value)
1082# $onclick -> (optional) Text of the JavaScript to run when the button is
1083# clicked.
1084# Returns:
1085# A string containing a <input type="button"> tag
1086####
1087'button' => <<'END_OF_FUNC',
1088sub button {
1089 my($self,@p) = self_or_default(@_);
1090
1091 my($label,$value,$script,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],
1092 [ONCLICK,SCRIPT],TABINDEX],@p);
1093
1094 $label=$self->escapeHTML($label);
1095 $value=$self->escapeHTML($value,1);
1096 $script=$self->escapeHTML($script);
1097
1098 my($name) = '';
1099 $name = qq/ name="$label"/ if $label;
1100 $value = $value || $label;
1101 my($val) = '';
1102 $val = qq/ value="$value"/ if $value;
1103 $script = qq/ onclick="$script"/ if $script;
1104 my($other) = @other ? " @other" : '';
1105 $tabindex = $self->element_tab($tabindex);
1106 return $XHTML ? qq(<input type="button" $tabindex$name$val$script$other />)
1107 : qq(<input type="button"$name$val$script$other>);
1108}
1109END_OF_FUNC
1110
1111
1112#### Method: submit
1113# Create a "submit query" button.
1114# Parameters:
1115# $name -> (optional) Name for the button.
1116# $value -> (optional) Value of the button when selected (also doubles as label).
1117# $label -> (optional) Label printed on the button(also doubles as the value).
1118# Returns:
1119# A string containing a <input type="submit"> tag
1120####
1121'submit' => <<'END_OF_FUNC',
1122sub submit {
1123 my($self,@p) = self_or_default(@_);
1124
1125 my($label,$value,$tabindex,@other) = rearrange([NAME,[VALUE,LABEL],TABINDEX],@p);
1126
1127 $label=$self->escapeHTML($label);
1128 $value=$self->escapeHTML($value,1);
1129
1130 my $name = $NOSTICKY ? '' : 'name=".submit" ';
1131 $name = qq/name="$label" / if defined($label);
1132 $value = defined($value) ? $value : $label;
1133 my $val = '';
1134 $val = qq/value="$value" / if defined($value);
1135 $tabindex = $self->element_tab($tabindex);
1136 my($other) = @other ? "@other " : '';
1137 return $XHTML ? qq(<input type="submit" $tabindex$name$val$other/>)
1138 : qq(<input type="submit" $name$val$other>);
1139}
1140END_OF_FUNC
1141
1142
1143#### Method: reset
1144# Create a "reset" button.
1145# Parameters:
1146# $name -> (optional) Name for the button.
1147# Returns:
1148# A string containing a <input type="reset"> tag
1149####
1150'reset' => <<'END_OF_FUNC',
1151sub reset {
1152 my($self,@p) = self_or_default(@_);
1153 my($label,$value,$tabindex,@other) = rearrange(['NAME',['VALUE','LABEL'],TABINDEX],@p);
1154 $label=$self->escapeHTML($label);
1155 $value=$self->escapeHTML($value,1);
1156 my ($name) = ' name=".reset"';
1157 $name = qq/ name="$label"/ if defined($label);
1158 $value = defined($value) ? $value : $label;
1159 my($val) = '';
1160 $val = qq/ value="$value"/ if defined($value);
1161 my($other) = @other ? " @other" : '';
1162 $tabindex = $self->element_tab($tabindex);
1163 return $XHTML ? qq(<input type="reset" $tabindex$name$val$other />)
1164 : qq(<input type="reset"$name$val$other>);
1165}
1166END_OF_FUNC
1167
1168
1169#### Method: defaults
1170# Create a "defaults" button.
1171# Parameters:
1172# $name -> (optional) Name for the button.
1173# Returns:
1174# A string containing a <input type="submit" name=".defaults"> tag
1175#
1176# Note: this button has a special meaning to the initialization script,
1177# and tells it to ERASE the current query string so that your defaults
1178# are used again!
1179####
1180'defaults' => <<'END_OF_FUNC',
1181sub defaults {
1182 my($self,@p) = self_or_default(@_);
1183
1184 my($label,$tabindex,@other) = rearrange([[NAME,VALUE],TABINDEX],@p);
1185
1186 $label=$self->escapeHTML($label,1);
1187 $label = $label || "Defaults";
1188 my($value) = qq/ value="$label"/;
1189 my($other) = @other ? " @other" : '';
1190 $tabindex = $self->element_tab($tabindex);
1191 return $XHTML ? qq(<input type="submit" name=".defaults" $tabindex$value$other />)
1192 : qq/<input type="submit" NAME=".defaults"$value$other>/;
1193}
1194END_OF_FUNC
1195
1196
1197#### Method: comment
1198# Create an HTML <!-- comment -->
1199# Parameters: a string
1200'comment' => <<'END_OF_FUNC',
1201sub comment {
1202 my($self,@p) = self_or_CGI(@_);
1203 return "<!-- @p -->";
1204}
1205END_OF_FUNC
1206
1207#### Method: checkbox
1208# Create a checkbox that is not logically linked to any others.
1209# The field value is "on" when the button is checked.
1210# Parameters:
1211# $name -> Name of the checkbox
1212# $checked -> (optional) turned on by default if true
1213# $value -> (optional) value of the checkbox, 'on' by default
1214# $label -> (optional) a user-readable label printed next to the box.
1215# Otherwise the checkbox name is used.
1216# Returns:
1217# A string containing a <input type="checkbox"> field
1218####
1219'checkbox' => <<'END_OF_FUNC',
1220sub checkbox {
1221 my($self,@p) = self_or_default(@_);
1222
1223 my($name,$checked,$value,$label,$labelattributes,$override,$tabindex,@other) =
1224 rearrange([NAME,[CHECKED,SELECTED,ON],VALUE,LABEL,LABELATTRIBUTES,
1225 [OVERRIDE,FORCE],TABINDEX],@p);
1226
1227 $value = defined $value ? $value : 'on';
1228
1229 if (!$override && ($self->{'.fieldnames'}->{$name} ||
1230 defined $self->param($name))) {
1231 $checked = grep($_ eq $value,$self->param($name)) ? $self->_checked(1) : '';
1232 } else {
1233 $checked = $self->_checked($checked);
1234 }
1235 my($the_label) = defined $label ? $label : $name;
1236 $name = $self->escapeHTML($name);
1237 $value = $self->escapeHTML($value,1);
1238 $the_label = $self->escapeHTML($the_label);
1239 my($other) = @other ? "@other " : '';
1240 $tabindex = $self->element_tab($tabindex);
1241 $self->register_parameter($name);
1242 return $XHTML ? CGI::label($labelattributes,
1243 qq{<input type="checkbox" name="$name" value="$value" $tabindex$checked$other/>$the_label})
1244 : qq{<input type="checkbox" name="$name" value="$value"$checked$other>$the_label};
1245}
1246END_OF_FUNC
1247
- -
1250# Escape HTML -- used internally
1251'escapeHTML' => <<'END_OF_FUNC',
1252sub escapeHTML {
1253 # hack to work around earlier hacks
1254 push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
1255 my ($self,$toencode,$newlinestoo) = CGI::self_or_default(@_);
1256 return undef unless defined($toencode);
1257 return $toencode if ref($self) && !$self->{'escape'};
1258 $toencode =~ s{&}{&amp;}gso;
1259 $toencode =~ s{<}{&lt;}gso;
1260 $toencode =~ s{>}{&gt;}gso;
1261 if ($DTD_PUBLIC_IDENTIFIER =~ /[^X]HTML 3\.2/i) {
1262 # $quot; was accidentally omitted from the HTML 3.2 DTD -- see
1263 # <http://validator.w3.org/docs/errors.html#bad-entity> /
1264 # <http://lists.w3.org/Archives/Public/www-html/1997Mar/0003.html>.
1265 $toencode =~ s{"}{&#34;}gso;
1266 }
1267 else {
1268 $toencode =~ s{"}{&quot;}gso;
1269 }
1270 # Handle bug in some browsers with Latin charsets
1271 if ($self->{'.charset'} &&
1272 (uc($self->{'.charset'}) eq 'ISO-8859-1' ||
1273 uc($self->{'.charset'}) eq 'WINDOWS-1252'))
1274 {
1275 $toencode =~ s{'}{&#39;}gso;
1276 $toencode =~ s{\x8b}{&#8249;}gso;
1277 $toencode =~ s{\x9b}{&#8250;}gso;
1278 if (defined $newlinestoo && $newlinestoo) {
1279 $toencode =~ s{\012}{&#10;}gso;
1280 $toencode =~ s{\015}{&#13;}gso;
1281 }
1282 }
1283 return $toencode;
1284}
1285END_OF_FUNC
1286
1287# unescape HTML -- used internally
1288'unescapeHTML' => <<'END_OF_FUNC',
1289sub unescapeHTML {
1290 # hack to work around earlier hacks
1291 push @_,$_[0] if @_==1 && $_[0] eq 'CGI';
1292 my ($self,$string) = CGI::self_or_default(@_);
1293 return undef unless defined($string);
1294 my $latin = defined $self->{'.charset'} ? $self->{'.charset'} =~ /^(ISO-8859-1|WINDOWS-1252)$/i
1295 : 1;
1296 # thanks to Randal Schwartz for the correct solution to this one
1297 $string=~ s[&(.*?);]{
1298 local $_ = $1;
1299 /^amp$/i ? "&" :
1300 /^quot$/i ? '"' :
1301 /^gt$/i ? ">" :
1302 /^lt$/i ? "<" :
1303 /^#(\d+)$/ && $latin ? chr($1) :
1304 /^#x([0-9a-f]+)$/i && $latin ? chr(hex($1)) :
1305 $_
1306 }gex;
1307 return $string;
1308}
1309END_OF_FUNC
1310
1311# Internal procedure - don't use
1312'_tableize' => <<'END_OF_FUNC',
1313sub _tableize {
1314 my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
1315 my @rowheaders = $rowheaders ? @$rowheaders : ();
1316 my @colheaders = $colheaders ? @$colheaders : ();
1317 my($result);
1318
1319 if (defined($columns)) {
1320 $rows = int(0.99 + @elements/$columns) unless defined($rows);
1321 }
1322 if (defined($rows)) {
1323 $columns = int(0.99 + @elements/$rows) unless defined($columns);
1324 }
1325
1326 # rearrange into a pretty table
1327 $result = "<table>";
1328 my($row,$column);
1329 unshift(@colheaders,'') if @colheaders && @rowheaders;
1330 $result .= "<tr>" if @colheaders;
1331 for (@colheaders) {
1332 $result .= "<th>$_</th>";
1333 }
1334 for ($row=0;$row<$rows;$row++) {
1335 $result .= "<tr>";
1336 $result .= "<th>$rowheaders[$row]</th>" if @rowheaders;
1337 for ($column=0;$column<$columns;$column++) {
1338 $result .= "<td>" . $elements[$column*$rows + $row] . "</td>"
1339 if defined($elements[$column*$rows + $row]);
1340 }
1341 $result .= "</tr>";
1342 }
1343 $result .= "</table>";
1344 return $result;
1345}
1346END_OF_FUNC
1347
1348
1349#### Method: radio_group
1350# Create a list of logically-linked radio buttons.
1351# Parameters:
1352# $name -> Common name for all the buttons.
1353# $values -> A pointer to a regular array containing the
1354# values for each button in the group.
1355# $default -> (optional) Value of the button to turn on by default. Pass '-'
1356# to turn _nothing_ on.
1357# $linebreak -> (optional) Set to true to place linebreaks
1358# between the buttons.
1359# $labels -> (optional)
1360# A pointer to a hash of labels to print next to each checkbox
1361# in the form $label{'value'}="Long explanatory label".
1362# Otherwise the provided values are used as the labels.
1363# Returns:
1364# An ARRAY containing a series of <input type="radio"> fields
1365####
1366'radio_group' => <<'END_OF_FUNC',
1367sub radio_group {
1368 my($self,@p) = self_or_default(@_);
1369 $self->_box_group('radio',@p);
1370}
1371END_OF_FUNC
1372
1373#### Method: checkbox_group
1374# Create a list of logically-linked checkboxes.
1375# Parameters:
1376# $name -> Common name for all the check boxes
1377# $values -> A pointer to a regular array containing the
1378# values for each checkbox in the group.
1379# $defaults -> (optional)
1380# 1. If a pointer to a regular array of checkbox values,
1381# then this will be used to decide which
1382# checkboxes to turn on by default.
1383# 2. If a scalar, will be assumed to hold the
1384# value of a single checkbox in the group to turn on.
1385# $linebreak -> (optional) Set to true to place linebreaks
1386# between the buttons.
1387# $labels -> (optional)
1388# A pointer to a hash of labels to print next to each checkbox
1389# in the form $label{'value'}="Long explanatory label".
1390# Otherwise the provided values are used as the labels.
1391# Returns:
1392# An ARRAY containing a series of <input type="checkbox"> fields
1393####
1394
1395'checkbox_group' => <<'END_OF_FUNC',
1396sub checkbox_group {
1397 my($self,@p) = self_or_default(@_);
1398 $self->_box_group('checkbox',@p);
1399}
1400END_OF_FUNC
1401
1402'_box_group' => <<'END_OF_FUNC',
1403sub _box_group {
1404 my $self = shift;
1405 my $box_type = shift;
1406
1407 my($name,$values,$defaults,$linebreak,$labels,$labelattributes,
1408 $attributes,$rows,$columns,$rowheaders,$colheaders,
1409 $override,$nolabels,$tabindex,$disabled,@other) =
1410 rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LINEBREAK,LABELS,LABELATTRIBUTES,
1411 ATTRIBUTES,ROWS,[COLUMNS,COLS],[ROWHEADERS,ROWHEADER],[COLHEADERS,COLHEADER],
1412 [OVERRIDE,FORCE],NOLABELS,TABINDEX,DISABLED
1413 ],@_);
1414
1415
1416 my($result,$checked,@elements,@values);
1417
1418 @values = $self->_set_values_and_labels($values,\$labels,$name);
1419 my %checked = $self->previous_or_default($name,$defaults,$override);
1420
1421 # If no check array is specified, check the first by default
1422 $checked{$values[0]}++ if $box_type eq 'radio' && !%checked;
1423
1424 $name=$self->escapeHTML($name);
1425
1426 my %tabs = ();
1427 if ($TABINDEX && $tabindex) {
1428 if (!ref $tabindex) {
1429 $self->element_tab($tabindex);
1430 } elsif (ref $tabindex eq 'ARRAY') {
1431 %tabs = map {$_=>$self->element_tab} @$tabindex;
1432 } elsif (ref $tabindex eq 'HASH') {
1433 %tabs = %$tabindex;
1434 }
1435 }
1436 %tabs = map {$_=>$self->element_tab} @values unless %tabs;
1437 my $other = @other ? "@other " : '';
1438 my $radio_checked;
1439
1440 # for disabling groups of radio/checkbox buttons
1441 my %disabled;
1442 for (@{$disabled}) {
1443 $disabled{$_}=1;
1444 }
1445
1446 for (@values) {
1447 my $disable="";
1448 if ($disabled{$_}) {
1449 $disable="disabled='1'";
1450 }
1451
1452 my $checkit = $self->_checked($box_type eq 'radio' ? ($checked{$_} && !$radio_checked++)
1453 : $checked{$_});
1454 my($break);
1455 if ($linebreak) {
1456 $break = $XHTML ? "<br />" : "<br>";
1457 }
1458 else {
1459 $break = '';
1460 }
1461 my($label)='';
1462 unless (defined($nolabels) && $nolabels) {
1463 $label = $_;
1464 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1465 $label = $self->escapeHTML($label,1);
1466 $label = "<span style=\"color:gray\">$label</span>" if $disabled{$_};
1467 }
1468 my $attribs = $self->_set_attributes($_, $attributes);
1469 my $tab = $tabs{$_};
1470 $_=$self->escapeHTML($_);
1471
1472 if ($XHTML) {
1473 push @elements,
1474 CGI::label($labelattributes,
1475 qq(<input type="$box_type" name="$name" value="$_" $checkit$other$tab$attribs$disable/>$label)).${break};
1476 } else {
1477 push(@elements,qq/<input type="$box_type" name="$name" value="$_"$checkit$other$tab$attribs$disable>${label}${break}/);
1478 }
1479 }
1480 $self->register_parameter($name);
1481 return wantarray ? @elements : "@elements"
1482 unless defined($columns) || defined($rows);
1483 return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
1484}
1485END_OF_FUNC
1486
1487
1488#### Method: popup_menu
1489# Create a popup menu.
1490# Parameters:
1491# $name -> Name for all the menu
1492# $values -> A pointer to a regular array containing the
1493# text of each menu item.
1494# $default -> (optional) Default item to display
1495# $labels -> (optional)
1496# A pointer to a hash of labels to print next to each checkbox
1497# in the form $label{'value'}="Long explanatory label".
1498# Otherwise the provided values are used as the labels.
1499# Returns:
1500# A string containing the definition of a popup menu.
1501####
1502'popup_menu' => <<'END_OF_FUNC',
1503sub popup_menu {
1504 my($self,@p) = self_or_default(@_);
1505
1506 my($name,$values,$default,$labels,$attributes,$override,$tabindex,@other) =
1507 rearrange([NAME,[VALUES,VALUE],[DEFAULT,DEFAULTS],LABELS,
1508 ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
1509 my($result,%selected);
1510
1511 if (!$override && defined($self->param($name))) {
1512 $selected{$self->param($name)}++;
1513 } elsif (defined $default) {
1514 %selected = map {$_=>1} ref($default) eq 'ARRAY'
1515 ? @$default
1516 : $default;
1517 }
1518 $name=$self->escapeHTML($name);
1519 my($other) = @other ? " @other" : '';
1520
1521 my(@values);
1522 @values = $self->_set_values_and_labels($values,\$labels,$name);
1523 $tabindex = $self->element_tab($tabindex);
1524 $result = qq/<select name="$name" $tabindex$other>\n/;
1525 for (@values) {
1526 if (/<optgroup/) {
1527 for my $v (split(/\n/)) {
1528 my $selectit = $XHTML ? 'selected="selected"' : 'selected';
1529 for my $selected (keys %selected) {
1530 $v =~ s/(value="$selected")/$selectit $1/;
1531 }
1532 $result .= "$v\n";
1533 }
1534 }
1535 else {
1536 my $attribs = $self->_set_attributes($_, $attributes);
1537 my($selectit) = $self->_selected($selected{$_});
1538 my($label) = $_;
1539 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1540 my($value) = $self->escapeHTML($_);
1541 $label = $self->escapeHTML($label,1);
1542 $result .= "<option${attribs} ${selectit}value=\"$value\">$label</option>\n";
1543 }
1544 }
1545
1546 $result .= "</select>";
1547 return $result;
1548}
1549END_OF_FUNC
1550
1551
1552#### Method: optgroup
1553# Create a optgroup.
1554# Parameters:
1555# $name -> Label for the group
1556# $values -> A pointer to a regular array containing the
1557# values for each option line in the group.
1558# $labels -> (optional)
1559# A pointer to a hash of labels to print next to each item
1560# in the form $label{'value'}="Long explanatory label".
1561# Otherwise the provided values are used as the labels.
1562# $labeled -> (optional)
1563# A true value indicates the value should be used as the label attribute
1564# in the option elements.
1565# The label attribute specifies the option label presented to the user.
1566# This defaults to the content of the <option> element, but the label
1567# attribute allows authors to more easily use optgroup without sacrificing
1568# compatibility with browsers that do not support option groups.
1569# $novals -> (optional)
1570# A true value indicates to suppress the val attribute in the option elements
1571# Returns:
1572# A string containing the definition of an option group.
1573####
1574'optgroup' => <<'END_OF_FUNC',
1575sub optgroup {
1576 my($self,@p) = self_or_default(@_);
1577 my($name,$values,$attributes,$labeled,$noval,$labels,@other)
1578 = rearrange([NAME,[VALUES,VALUE],ATTRIBUTES,LABELED,NOVALS,LABELS],@p);
1579
1580 my($result,@values);
1581 @values = $self->_set_values_and_labels($values,\$labels,$name,$labeled,$novals);
1582 my($other) = @other ? " @other" : '';
1583
1584 $name=$self->escapeHTML($name);
1585 $result = qq/<optgroup label="$name"$other>\n/;
1586 for (@values) {
1587 if (/<optgroup/) {
1588 for (split(/\n/)) {
1589 my $selectit = $XHTML ? 'selected="selected"' : 'selected';
1590 s/(value="$selected")/$selectit $1/ if defined $selected;
1591 $result .= "$_\n";
1592 }
1593 }
1594 else {
1595 my $attribs = $self->_set_attributes($_, $attributes);
1596 my($label) = $_;
1597 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1598 $label=$self->escapeHTML($label);
1599 my($value)=$self->escapeHTML($_,1);
1600 $result .= $labeled ? $novals ? "<option$attribs label=\"$value\">$label</option>\n"
1601 : "<option$attribs label=\"$value\" value=\"$value\">$label</option>\n"
1602 : $novals ? "<option$attribs>$label</option>\n"
1603 : "<option$attribs value=\"$value\">$label</option>\n";
1604 }
1605 }
1606 $result .= "</optgroup>";
1607 return $result;
1608}
1609END_OF_FUNC
1610
1611
1612#### Method: scrolling_list
1613# Create a scrolling list.
1614# Parameters:
1615# $name -> name for the list
1616# $values -> A pointer to a regular array containing the
1617# values for each option line in the list.
1618# $defaults -> (optional)
1619# 1. If a pointer to a regular array of options,
1620# then this will be used to decide which
1621# lines to turn on by default.
1622# 2. Otherwise holds the value of the single line to turn on.
1623# $size -> (optional) Size of the list.
1624# $multiple -> (optional) If set, allow multiple selections.
1625# $labels -> (optional)
1626# A pointer to a hash of labels to print next to each checkbox
1627# in the form $label{'value'}="Long explanatory label".
1628# Otherwise the provided values are used as the labels.
1629# Returns:
1630# A string containing the definition of a scrolling list.
1631####
1632'scrolling_list' => <<'END_OF_FUNC',
1633sub scrolling_list {
1634 my($self,@p) = self_or_default(@_);
1635 my($name,$values,$defaults,$size,$multiple,$labels,$attributes,$override,$tabindex,@other)
1636 = rearrange([NAME,[VALUES,VALUE],[DEFAULTS,DEFAULT],
1637 SIZE,MULTIPLE,LABELS,ATTRIBUTES,[OVERRIDE,FORCE],TABINDEX],@p);
1638
1639 my($result,@values);
1640 @values = $self->_set_values_and_labels($values,\$labels,$name);
1641
1642 $size = $size || scalar(@values);
1643
1644 my(%selected) = $self->previous_or_default($name,$defaults,$override);
1645
1646 my($is_multiple) = $multiple ? qq/ multiple="multiple"/ : '';
1647 my($has_size) = $size ? qq/ size="$size"/: '';
1648 my($other) = @other ? " @other" : '';
1649
1650 $name=$self->escapeHTML($name);
1651 $tabindex = $self->element_tab($tabindex);
1652 $result = qq/<select name="$name" $tabindex$has_size$is_multiple$other>\n/;
1653 for (@values) {
1654 my($selectit) = $self->_selected($selected{$_});
1655 my($label) = $_;
1656 $label = $labels->{$_} if defined($labels) && defined($labels->{$_});
1657 $label=$self->escapeHTML($label);
1658 my($value)=$self->escapeHTML($_,1);
1659 my $attribs = $self->_set_attributes($_, $attributes);
1660 $result .= "<option ${selectit}${attribs}value=\"$value\">$label</option>\n";
1661 }
1662 $result .= "</select>";
1663 $self->register_parameter($name);
1664 return $result;
1665}
1666END_OF_FUNC
1667
1668
1669#### Method: hidden
1670# Parameters:
1671# $name -> Name of the hidden field
1672# @default -> (optional) Initial values of field (may be an array)
1673# or
1674# $default->[initial values of field]
1675# Returns:
1676# A string containing a <input type="hidden" name="name" value="value">
1677####
1678'hidden' => <<'END_OF_FUNC',
1679sub hidden {
1680 my($self,@p) = self_or_default(@_);
1681
1682 # this is the one place where we departed from our standard
1683 # calling scheme, so we have to special-case (darn)
1684 my(@result,@value);
1685 my($name,$default,$override,@other) =
1686 rearrange([NAME,[DEFAULT,VALUE,VALUES],[OVERRIDE,FORCE]],@p);
1687
1688 my $do_override = 0;
1689 if ( ref($p[0]) || substr($p[0],0,1) eq '-') {
1690 @value = ref($default) ? @{$default} : $default;
1691 $do_override = $override;
1692 } else {
1693 for ($default,$override,@other) {
1694 push(@value,$_) if defined($_);
1695 }
1696 }
1697
1698 # use previous values if override is not set
1699 my @prev = $self->param($name);
1700 @value = @prev if !$do_override && @prev;
1701
1702 $name=$self->escapeHTML($name);
1703 for (@value) {
1704 $_ = defined($_) ? $self->escapeHTML($_,1) : '';
1705 push @result,$XHTML ? qq(<input type="hidden" name="$name" value="$_" @other />)
1706 : qq(<input type="hidden" name="$name" value="$_" @other>);
1707 }
1708 return wantarray ? @result : join('',@result);
1709}
1710END_OF_FUNC
1711
1712
1713#### Method: image_button
1714# Parameters:
1715# $name -> Name of the button
1716# $src -> URL of the image source
1717# $align -> Alignment style (TOP, BOTTOM or MIDDLE)
1718# Returns:
1719# A string containing a <input type="image" name="name" src="url" align="alignment">
1720####
1721'image_button' => <<'END_OF_FUNC',
1722sub image_button {
1723 my($self,@p) = self_or_default(@_);
1724
1725 my($name,$src,$alignment,@other) =
1726 rearrange([NAME,SRC,ALIGN],@p);
1727
1728 my($align) = $alignment ? " align=\L\"$alignment\"" : '';
1729 my($other) = @other ? " @other" : '';
1730 $name=$self->escapeHTML($name);
1731 return $XHTML ? qq(<input type="image" name="$name" src="$src"$align$other />)
1732 : qq/<input type="image" name="$name" src="$src"$align$other>/;
1733}
1734END_OF_FUNC
1735
1736
1737#### Method: self_url
1738# Returns a URL containing the current script and all its
1739# param/value pairs arranged as a query. You can use this
1740# to create a link that, when selected, will reinvoke the
1741# script with all its state information preserved.
1742####
1743'self_url' => <<'END_OF_FUNC',
1744sub self_url {
1745 my($self,@p) = self_or_default(@_);
1746 return $self->url('-path_info'=>1,'-query'=>1,'-full'=>1,@p);
1747}
1748END_OF_FUNC
1749
1750
1751# This is provided as a synonym to self_url() for people unfortunate
1752# enough to have incorporated it into their programs already!
1753'state' => <<'END_OF_FUNC',
1754sub state {
1755 &self_url;
1756}
1757END_OF_FUNC
1758
1759
1760#### Method: url
1761# Like self_url, but doesn't return the query string part of
1762# the URL.
1763####
1764'url' => <<'END_OF_FUNC',
1765sub url {
1766 my($self,@p) = self_or_default(@_);
1767 my ($relative,$absolute,$full,$path_info,$query,$base,$rewrite) =
1768 rearrange(['RELATIVE','ABSOLUTE','FULL',['PATH','PATH_INFO'],['QUERY','QUERY_STRING'],'BASE','REWRITE'],@p);
1769 my $url = '';
1770 $full++ if $base || !($relative || $absolute);
1771 $rewrite++ unless defined $rewrite;
1772
1773 my $path = $self->path_info;
1774 my $script_name = $self->script_name;
1775 my $request_uri = unescape($self->request_uri) || '';
1776 my $query_str = $self->query_string;
1777
1778 my $rewrite_in_use = $request_uri && $request_uri !~ /^\Q$script_name/;
1779 undef $path if $rewrite_in_use && $rewrite; # path not valid when rewriting active
1780
1781 my $uri = $rewrite && $request_uri ? $request_uri : $script_name;
1782 $uri =~ s/\?.*$//s; # remove query string
1783 $uri =~ s/\Q$ENV{PATH_INFO}\E$// if defined $ENV{PATH_INFO};
1784# $uri =~ s/\Q$path\E$// if defined $path; # remove path
1785
1786 if ($full) {
1787 my $protocol = $self->protocol();
1788 $url = "$protocol://";
1789 my $vh = http('x_forwarded_host') || http('host') || '';
1790 $vh =~ s/\:\d+$//; # some clients add the port number (incorrectly). Get rid of it.
1791 if ($vh) {
1792 $url .= $vh;
1793 } else {
1794 $url .= server_name();
1795 }
1796 my $port = $self->server_port;
1797 $url .= ":" . $port
1798 unless (lc($protocol) eq 'http' && $port == 80)
1799 || (lc($protocol) eq 'https' && $port == 443);
1800 return $url if $base;
1801 $url .= $uri;
1802 } elsif ($relative) {
1803 ($url) = $uri =~ m!([^/]+)$!;
1804 } elsif ($absolute) {
1805 $url = $uri;
1806 }
1807
1808 $url .= $path if $path_info and defined $path;
1809 $url .= "?$query_str" if $query and $query_str ne '';
1810 $url ||= '';
1811 $url =~ s/([^a-zA-Z0-9_.%;&?\/\\:+=~-])/sprintf("%%%02X",ord($1))/eg;
1812 return $url;
1813}
1814
1815END_OF_FUNC
1816
1817#### Method: cookie
1818# Set or read a cookie from the specified name.
1819# Cookie can then be passed to header().
1820# Usual rules apply to the stickiness of -value.
1821# Parameters:
1822# -name -> name for this cookie (optional)
1823# -value -> value of this cookie (scalar, array or hash)
1824# -path -> paths for which this cookie is valid (optional)
1825# -domain -> internet domain in which this cookie is valid (optional)
1826# -secure -> if true, cookie only passed through secure channel (optional)
1827# -expires -> expiry date in format Wdy, DD-Mon-YYYY HH:MM:SS GMT (optional)
1828####
1829'cookie' => <<'END_OF_FUNC',
1830sub cookie {
1831 my($self,@p) = self_or_default(@_);
1832 my($name,$value,$path,$domain,$secure,$expires,$httponly) =
1833 rearrange([NAME,[VALUE,VALUES],PATH,DOMAIN,SECURE,EXPIRES,HTTPONLY],@p);
1834
1835 require CGI::Cookie;
1836
1837 # if no value is supplied, then we retrieve the
1838 # value of the cookie, if any. For efficiency, we cache the parsed
1839 # cookies in our state variables.
1840 unless ( defined($value) ) {
1841 $self->{'.cookies'} = CGI::Cookie->fetch
1842 unless $self->{'.cookies'};
1843
1844 # If no name is supplied, then retrieve the names of all our cookies.
1845 return () unless $self->{'.cookies'};
1846 return keys %{$self->{'.cookies'}} unless $name;
1847 return () unless $self->{'.cookies'}->{$name};
1848 return $self->{'.cookies'}->{$name}->value if defined($name) && $name ne '';
1849 }
1850
1851 # If we get here, we're creating a new cookie
1852 return undef unless defined($name) && $name ne ''; # this is an error
1853
1854 my @param;
1855 push(@param,'-name'=>$name);
1856 push(@param,'-value'=>$value);
1857 push(@param,'-domain'=>$domain) if $domain;
1858 push(@param,'-path'=>$path) if $path;
1859 push(@param,'-expires'=>$expires) if $expires;
1860 push(@param,'-secure'=>$secure) if $secure;
1861 push(@param,'-httponly'=>$httponly) if $httponly;
1862
1863 return new CGI::Cookie(@param);
1864}
1865END_OF_FUNC
1866
1867'parse_keywordlist' => <<'END_OF_FUNC',
1868sub parse_keywordlist {
1869 my($self,$tosplit) = @_;
1870 $tosplit = unescape($tosplit); # unescape the keywords
1871 $tosplit=~tr/+/ /; # pluses to spaces
1872 my(@keywords) = split(/\s+/,$tosplit);
1873 return @keywords;
1874}
1875END_OF_FUNC
1876
1877'param_fetch' => <<'END_OF_FUNC',
1878sub param_fetch {
1879 my($self,@p) = self_or_default(@_);
1880 my($name) = rearrange([NAME],@p);
1881 unless (exists($self->{param}{$name})) {
1882 $self->add_parameter($name);
1883 $self->{param}{$name} = [];
1884 }
1885
1886 return $self->{param}{$name};
1887}
1888END_OF_FUNC
1889
1890###############################################
1891# OTHER INFORMATION PROVIDED BY THE ENVIRONMENT
1892###############################################
1893
1894#### Method: path_info
1895# Return the extra virtual path information provided
1896# after the URL (if any)
1897####
1898'path_info' => <<'END_OF_FUNC',
1899sub path_info {
1900 my ($self,$info) = self_or_default(@_);
1901 if (defined($info)) {
1902 $info = "/$info" if $info ne '' && substr($info,0,1) ne '/';
1903 $self->{'.path_info'} = $info;
1904 } elsif (! defined($self->{'.path_info'}) ) {
1905 my (undef,$path_info) = $self->_name_and_path_from_env;
1906 $self->{'.path_info'} = $path_info || '';
1907 }
1908 return $self->{'.path_info'};
1909}
1910END_OF_FUNC
1911
1912# This function returns a potentially modified version of SCRIPT_NAME
1913# and PATH_INFO. Some HTTP servers do sanitise the paths in those
1914# variables. It is the case of at least Apache 2. If for instance the
1915# user requests: /path/./to/script.cgi/x//y/z/../x?y, Apache will set:
1916# REQUEST_URI=/path/./to/script.cgi/x//y/z/../x?y
1917# SCRIPT_NAME=/path/to/env.cgi
1918# PATH_INFO=/x/y/x
1919#
1920# This is all fine except that some bogus CGI scripts expect
1921# PATH_INFO=/http://foo when the user requests
1922# http://xxx/script.cgi/http://foo
1923#
1924# Old versions of this module used to accomodate with those scripts, so
1925# this is why we do this here to keep those scripts backward compatible.
1926# Basically, we accomodate with those scripts but within limits, that is
1927# we only try to preserve the number of / that were provided by the user
1928# if $REQUEST_URI and "$SCRIPT_NAME$PATH_INFO" only differ by the number
1929# of consecutive /.
1930#
1931# So for instance, in: http://foo/x//y/script.cgi/a//b, we'll return a
1932# script_name of /x//y/script.cgi and a path_info of /a//b, but in:
1933# http://foo/./x//z/script.cgi/a/../b//c, we'll return the versions
1934# possibly sanitised by the HTTP server, so in the case of Apache 2:
1935# script_name == /foo/x/z/script.cgi and path_info == /b/c.
1936#
1937# Future versions of this module may no longer do that, so one should
1938# avoid relying on the browser, proxy, server, and CGI.pm preserving the
1939# number of consecutive slashes as no guarantee can be made there.
1940'_name_and_path_from_env' => <<'END_OF_FUNC',
1941sub _name_and_path_from_env {
1942 my $self = shift;
1943 my $script_name = $ENV{SCRIPT_NAME} || '';
1944 my $path_info = $ENV{PATH_INFO} || '';
1945 my $uri = $self->request_uri || '';
1946
1947 $uri =~ s/\?.*//s;
1948 $uri = unescape($uri);
1949
1950 if ($uri ne "$script_name$path_info") {
1951 my $script_name_pattern = quotemeta($script_name);
1952 my $path_info_pattern = quotemeta($path_info);
1953 $script_name_pattern =~ s{(?:\\/)+}{/+}g;
1954 $path_info_pattern =~ s{(?:\\/)+}{/+}g;
1955
1956 if ($uri =~ /^($script_name_pattern)($path_info_pattern)$/s) {
1957 # REQUEST_URI and SCRIPT_NAME . PATH_INFO only differ by the
1958 # numer of consecutive slashes, so we can extract the info from
1959 # REQUEST_URI:
1960 ($script_name, $path_info) = ($1, $2);
1961 }
1962 }
1963 return ($script_name,$path_info);
1964}
1965END_OF_FUNC
1966
1967
1968#### Method: request_method
1969# Returns 'POST', 'GET', 'PUT' or 'HEAD'
1970####
1971'request_method' => <<'END_OF_FUNC',
1972sub request_method {
1973 return $ENV{'REQUEST_METHOD'};
1974}
1975END_OF_FUNC
1976
1977#### Method: content_type
1978# Returns the content_type string
1979####
1980'content_type' => <<'END_OF_FUNC',
1981sub content_type {
1982 return $ENV{'CONTENT_TYPE'};
1983}
1984END_OF_FUNC
1985
1986#### Method: path_translated
1987# Return the physical path information provided
1988# by the URL (if any)
1989####
1990'path_translated' => <<'END_OF_FUNC',
1991sub path_translated {
1992 return $ENV{'PATH_TRANSLATED'};
1993}
1994END_OF_FUNC
1995
1996
1997#### Method: request_uri
1998# Return the literal request URI
1999####
2000'request_uri' => <<'END_OF_FUNC',
2001sub request_uri {
2002 return $ENV{'REQUEST_URI'};
2003}
2004END_OF_FUNC
2005
2006
2007#### Method: query_string
2008# Synthesize a query string from our current
2009# parameters
2010####
2011'query_string' => <<'END_OF_FUNC',
2012sub query_string {
2013 my($self) = self_or_default(@_);
2014 my($param,$value,@pairs);
2015 for $param ($self->param) {
2016 my($eparam) = escape($param);
2017 for $value ($self->param($param)) {
2018 $value = escape($value);
2019 next unless defined $value;
2020 push(@pairs,"$eparam=$value");
2021 }
2022 }
2023 for (keys %{$self->{'.fieldnames'}}) {
2024 push(@pairs,".cgifields=".escape("$_"));
2025 }
2026 return join($USE_PARAM_SEMICOLONS ? ';' : '&',@pairs);
2027}
2028END_OF_FUNC
2029
2030
2031#### Method: accept
2032# Without parameters, returns an array of the
2033# MIME types the browser accepts.
2034# With a single parameter equal to a MIME
2035# type, will return undef if the browser won't
2036# accept it, 1 if the browser accepts it but
2037# doesn't give a preference, or a floating point
2038# value between 0.0 and 1.0 if the browser
2039# declares a quantitative score for it.
2040# This handles MIME type globs correctly.
2041####
2042'Accept' => <<'END_OF_FUNC',
2043sub Accept {
2044 my($self,$search) = self_or_CGI(@_);
2045 my(%prefs,$type,$pref,$pat);
2046
2047 my(@accept) = defined $self->http('accept')
2048 ? split(',',$self->http('accept'))
2049 : ();
2050
2051 for (@accept) {
2052 ($pref) = /q=(\d\.\d+|\d+)/;
2053 ($type) = m#(\S+/[^;]+)#;
2054 next unless $type;
2055 $prefs{$type}=$pref || 1;
2056 }
2057
2058 return keys %prefs unless $search;
2059
2060 # if a search type is provided, we may need to
2061 # perform a pattern matching operation.
2062 # The MIME types use a glob mechanism, which
2063 # is easily translated into a perl pattern match
2064
2065 # First return the preference for directly supported
2066 # types:
2067 return $prefs{$search} if $prefs{$search};
2068
2069 # Didn't get it, so try pattern matching.
2070 for (keys %prefs) {
2071 next unless /\*/; # not a pattern match
2072 ($pat = $_) =~ s/([^\w*])/\\$1/g; # escape meta characters
2073 $pat =~ s/\*/.*/g; # turn it into a pattern
2074 return $prefs{$_} if $search=~/$pat/;
2075 }
2076}
2077END_OF_FUNC
2078
2079
2080#### Method: user_agent
2081# If called with no parameters, returns the user agent.
2082# If called with one parameter, does a pattern match (case
2083# insensitive) on the user agent.
2084####
2085'user_agent' => <<'END_OF_FUNC',
2086sub user_agent {
2087 my($self,$match)=self_or_CGI(@_);
2088 return $self->http('user_agent') unless $match;
2089 return $self->http('user_agent') =~ /$match/i;
2090}
2091END_OF_FUNC
2092
2093
2094#### Method: raw_cookie
2095# Returns the magic cookies for the session.
2096# The cookies are not parsed or altered in any way, i.e.
2097# cookies are returned exactly as given in the HTTP
2098# headers. If a cookie name is given, only that cookie's
2099# value is returned, otherwise the entire raw cookie
2100# is returned.
2101####
2102'raw_cookie' => <<'END_OF_FUNC',
2103sub raw_cookie {
2104 my($self,$key) = self_or_CGI(@_);
2105
2106 require CGI::Cookie;
2107
2108 if (defined($key)) {
2109 $self->{'.raw_cookies'} = CGI::Cookie->raw_fetch
2110 unless $self->{'.raw_cookies'};
2111
2112 return () unless $self->{'.raw_cookies'};
2113 return () unless $self->{'.raw_cookies'}->{$key};
2114 return $self->{'.raw_cookies'}->{$key};
2115 }
2116 return $self->http('cookie') || $ENV{'COOKIE'} || '';
2117}
2118END_OF_FUNC
2119
2120#### Method: virtual_host
2121# Return the name of the virtual_host, which
2122# is not always the same as the server
2123######
2124'virtual_host' => <<'END_OF_FUNC',
2125sub virtual_host {
2126 my $vh = http('x_forwarded_host') || http('host') || server_name();
2127 $vh =~ s/:\d+$//; # get rid of port number
2128 return $vh;
2129}
2130END_OF_FUNC
2131
2132#### Method: remote_host
2133# Return the name of the remote host, or its IP
2134# address if unavailable. If this variable isn't
2135# defined, it returns "localhost" for debugging
2136# purposes.
2137####
2138'remote_host' => <<'END_OF_FUNC',
2139sub remote_host {
2140 return $ENV{'REMOTE_HOST'} || $ENV{'REMOTE_ADDR'}
2141 || 'localhost';
2142}
2143END_OF_FUNC
2144
2145
2146#### Method: remote_addr
2147# Return the IP addr of the remote host.
2148####
2149'remote_addr' => <<'END_OF_FUNC',
2150sub remote_addr {
2151 return $ENV{'REMOTE_ADDR'} || '127.0.0.1';
2152}
2153END_OF_FUNC
2154
2155
2156#### Method: script_name
2157# Return the partial URL to this script for
2158# self-referencing scripts. Also see
2159# self_url(), which returns a URL with all state information
2160# preserved.
2161####
2162'script_name' => <<'END_OF_FUNC',
2163sub script_name {
2164 my ($self,@p) = self_or_default(@_);
2165 if (@p) {
2166 $self->{'.script_name'} = shift @p;
2167 } elsif (!exists $self->{'.script_name'}) {
2168 my ($script_name,$path_info) = $self->_name_and_path_from_env();
2169 $self->{'.script_name'} = $script_name;
2170 }
2171 return $self->{'.script_name'};
2172}
2173END_OF_FUNC
2174
2175
2176#### Method: referer
2177# Return the HTTP_REFERER: useful for generating
2178# a GO BACK button.
2179####
2180'referer' => <<'END_OF_FUNC',
2181sub referer {
2182 my($self) = self_or_CGI(@_);
2183 return $self->http('referer');
2184}
2185END_OF_FUNC
2186
2187
2188#### Method: server_name
2189# Return the name of the server
2190####
2191'server_name' => <<'END_OF_FUNC',
2192sub server_name {
2193 return $ENV{'SERVER_NAME'} || 'localhost';
2194}
2195END_OF_FUNC
2196
2197#### Method: server_software
2198# Return the name of the server software
2199####
2200'server_software' => <<'END_OF_FUNC',
2201sub server_software {
2202 return $ENV{'SERVER_SOFTWARE'} || 'cmdline';
2203}
2204END_OF_FUNC
2205
2206#### Method: virtual_port
2207# Return the server port, taking virtual hosts into account
2208####
2209'virtual_port' => <<'END_OF_FUNC',
2210sub virtual_port {
2211 my($self) = self_or_default(@_);
2212 my $vh = $self->http('x_forwarded_host') || $self->http('host');
2213 my $protocol = $self->protocol;
2214 if ($vh) {
2215 return ($vh =~ /:(\d+)$/)[0] || ($protocol eq 'https' ? 443 : 80);
2216 } else {
2217 return $self->server_port();
2218 }
2219}
2220END_OF_FUNC
2221
2222#### Method: server_port
2223# Return the tcp/ip port the server is running on
2224####
2225'server_port' => <<'END_OF_FUNC',
2226sub server_port {
2227 return $ENV{'SERVER_PORT'} || 80; # for debugging
2228}
2229END_OF_FUNC
2230
2231#### Method: server_protocol
2232# Return the protocol (usually HTTP/1.0)
2233####
2234'server_protocol' => <<'END_OF_FUNC',
2235sub server_protocol {
2236 return $ENV{'SERVER_PROTOCOL'} || 'HTTP/1.0'; # for debugging
2237}
2238END_OF_FUNC
2239
2240#### Method: http
2241# Return the value of an HTTP variable, or
2242# the list of variables if none provided
2243####
2244'http' => <<'END_OF_FUNC',
2245sub http {
2246 my ($self,$parameter) = self_or_CGI(@_);
2247 return $ENV{$parameter} if $parameter=~/^HTTP/;
2248 $parameter =~ tr/-/_/;
2249 return $ENV{"HTTP_\U$parameter\E"} if $parameter;
2250 my(@p);
2251 for (keys %ENV) {
2252 push(@p,$_) if /^HTTP/;
2253 }
2254 return @p;
2255}
2256END_OF_FUNC
2257
2258#### Method: https
2259# Return the value of HTTPS
2260####
2261'https' => <<'END_OF_FUNC',
2262sub https {
2263 local($^W)=0;
2264 my ($self,$parameter) = self_or_CGI(@_);
2265 return $ENV{HTTPS} unless $parameter;
2266 return $ENV{$parameter} if $parameter=~/^HTTPS/;
2267 $parameter =~ tr/-/_/;
2268 return $ENV{"HTTPS_\U$parameter\E"} if $parameter;
2269 my(@p);
2270 for (keys %ENV) {
2271 push(@p,$_) if /^HTTPS/;
2272 }
2273 return @p;
2274}
2275END_OF_FUNC
2276
2277#### Method: protocol
2278# Return the protocol (http or https currently)
2279####
2280'protocol' => <<'END_OF_FUNC',
2281sub protocol {
2282 local($^W)=0;
2283 my $self = shift;
2284 return 'https' if uc($self->https()) eq 'ON';
2285 return 'https' if $self->server_port == 443;
2286 my $prot = $self->server_protocol;
2287 my($protocol,$version) = split('/',$prot);
2288 return "\L$protocol\E";
2289}
2290END_OF_FUNC
2291
2292#### Method: remote_ident
2293# Return the identity of the remote user
2294# (but only if his host is running identd)
2295####
2296'remote_ident' => <<'END_OF_FUNC',
2297sub remote_ident {
2298 return $ENV{'REMOTE_IDENT'};
2299}
2300END_OF_FUNC
2301
2302
2303#### Method: auth_type
2304# Return the type of use verification/authorization in use, if any.
2305####
2306'auth_type' => <<'END_OF_FUNC',
2307sub auth_type {
2308 return $ENV{'AUTH_TYPE'};
2309}
2310END_OF_FUNC
2311
2312
2313#### Method: remote_user
2314# Return the authorization name used for user
2315# verification.
2316####
2317'remote_user' => <<'END_OF_FUNC',
2318sub remote_user {
2319 return $ENV{'REMOTE_USER'};
2320}
2321END_OF_FUNC
2322
2323
2324#### Method: user_name
2325# Try to return the remote user's name by hook or by
2326# crook
2327####
2328'user_name' => <<'END_OF_FUNC',
2329sub user_name {
2330 my ($self) = self_or_CGI(@_);
2331 return $self->http('from') || $ENV{'REMOTE_IDENT'} || $ENV{'REMOTE_USER'};
2332}
2333END_OF_FUNC
2334
2335#### Method: nosticky
2336# Set or return the NOSTICKY global flag
2337####
2338'nosticky' => <<'END_OF_FUNC',
2339sub nosticky {
2340 my ($self,$param) = self_or_CGI(@_);
2341 $CGI::NOSTICKY = $param if defined($param);
2342 return $CGI::NOSTICKY;
2343}
2344END_OF_FUNC
2345
2346#### Method: nph
2347# Set or return the NPH global flag
2348####
2349'nph' => <<'END_OF_FUNC',
2350sub nph {
2351 my ($self,$param) = self_or_CGI(@_);
2352 $CGI::NPH = $param if defined($param);
2353 return $CGI::NPH;
2354}
2355END_OF_FUNC
2356
2357#### Method: private_tempfiles
2358# Set or return the private_tempfiles global flag
2359####
2360'private_tempfiles' => <<'END_OF_FUNC',
2361sub private_tempfiles {
2362 my ($self,$param) = self_or_CGI(@_);
2363 $CGI::PRIVATE_TEMPFILES = $param if defined($param);
2364 return $CGI::PRIVATE_TEMPFILES;
2365}
2366END_OF_FUNC
2367#### Method: close_upload_files
2368# Set or return the close_upload_files global flag
2369####
2370'close_upload_files' => <<'END_OF_FUNC',
2371sub close_upload_files {
2372 my ($self,$param) = self_or_CGI(@_);
2373 $CGI::CLOSE_UPLOAD_FILES = $param if defined($param);
2374 return $CGI::CLOSE_UPLOAD_FILES;
2375}
2376END_OF_FUNC
2377
2378
2379#### Method: default_dtd
2380# Set or return the default_dtd global
2381####
2382'default_dtd' => <<'END_OF_FUNC',
2383sub default_dtd {
2384 my ($self,$param,$param2) = self_or_CGI(@_);
2385 if (defined $param2 && defined $param) {
2386 $CGI::DEFAULT_DTD = [ $param, $param2 ];
2387 } elsif (defined $param) {
2388 $CGI::DEFAULT_DTD = $param;
2389 }
2390 return $CGI::DEFAULT_DTD;
2391}
2392END_OF_FUNC
2393
2394# -------------- really private subroutines -----------------
2395'previous_or_default' => <<'END_OF_FUNC',
2396sub previous_or_default {
2397 my($self,$name,$defaults,$override) = @_;
2398 my(%selected);
2399
2400 if (!$override && ($self->{'.fieldnames'}->{$name} ||
2401 defined($self->param($name)) ) ) {
2402 $selected{$_}++ for $self->param($name);
2403 } elsif (defined($defaults) && ref($defaults) &&
2404 (ref($defaults) eq 'ARRAY')) {
2405 $selected{$_}++ for @{$defaults};
2406 } else {
2407 $selected{$defaults}++ if defined($defaults);
2408 }
2409
2410 return %selected;
2411}
2412END_OF_FUNC
2413
2414'register_parameter' => <<'END_OF_FUNC',
2415sub register_parameter {
2416 my($self,$param) = @_;
2417 $self->{'.parametersToAdd'}->{$param}++;
2418}
2419END_OF_FUNC
2420
2421'get_fields' => <<'END_OF_FUNC',
2422sub get_fields {
2423 my($self) = @_;
2424 return $self->CGI::hidden('-name'=>'.cgifields',
2425 '-values'=>[keys %{$self->{'.parametersToAdd'}}],
2426 '-override'=>1);
2427}
2428END_OF_FUNC
2429
2430'read_from_cmdline' => <<'END_OF_FUNC',
2431sub read_from_cmdline {
2432 my($input,@words);
2433 my($query_string);
2434 my($subpath);
2435 if ($DEBUG && @ARGV) {
2436 @words = @ARGV;
2437 } elsif ($DEBUG > 1) {
2438 require "shellwords.pl";
2439 print STDERR "(offline mode: enter name=value pairs on standard input; press ^D or ^Z when done)\n";
2440 chomp(@lines = <STDIN>); # remove newlines
2441 $input = join(" ",@lines);
2442 @words = &shellwords($input);
2443 }
2444 for (@words) {
2445 s/\\=/%3D/g;
2446 s/\\&/%26/g;
2447 }
2448
2449 if ("@words"=~/=/) {
2450 $query_string = join('&',@words);
2451 } else {
2452 $query_string = join('+',@words);
2453 }
2454 if ($query_string =~ /^(.*?)\?(.*)$/)
2455 {
2456 $query_string = $2;
2457 $subpath = $1;
2458 }
2459 return { 'query_string' => $query_string, 'subpath' => $subpath };
2460}
2461END_OF_FUNC
2462
2463#####
2464# subroutine: read_multipart
2465#
2466# Read multipart data and store it into our parameters.
2467# An interesting feature is that if any of the parts is a file, we
2468# create a temporary file and open up a filehandle on it so that the
2469# caller can read from it if necessary.
2470#####
2471'read_multipart' => <<'END_OF_FUNC',
2472sub read_multipart {
2473 my($self,$boundary,$length) = @_;
2474 my($buffer) = $self->new_MultipartBuffer($boundary,$length);
2475 return unless $buffer;
2476 my(%header,$body);
2477 my $filenumber = 0;
2478 while (!$buffer->eof) {
2479 %header = $buffer->readHeader;
2480
2481 unless (%header) {
2482 $self->cgi_error("400 Bad request (malformed multipart POST)");
2483 return;
2484 }
2485
2486 $header{'Content-Disposition'} ||= ''; # quench uninit variable warning
2487
2488 my($param)= $header{'Content-Disposition'}=~/ name="([^"]*)"/;
2489 $param .= $TAINTED;
2490
2491 # See RFC 1867, 2183, 2045
2492 # NB: File content will be loaded into memory should
2493 # content-disposition parsing fail.
2494 my ($filename) = $header{'Content-Disposition'}
2495 =~/ filename=(("[^"]*")|([a-z\d!\#'\*\+,\.^_\`\{\}\|\~]*))/i;
2496
2497 $filename ||= ''; # quench uninit variable warning
2498
2499 $filename =~ s/^"([^"]*)"$/$1/;
2500 # Test for Opera's multiple upload feature
2501 my($multipart) = ( defined( $header{'Content-Type'} ) &&
2502 $header{'Content-Type'} =~ /multipart\/mixed/ ) ?
2503 1 : 0;
2504
2505 # add this parameter to our list
2506 $self->add_parameter($param);
2507
2508 # If no filename specified, then just read the data and assign it
2509 # to our parameter list.
2510 if ( ( !defined($filename) || $filename eq '' ) && !$multipart ) {
2511 my($value) = $buffer->readBody;
2512 $value .= $TAINTED;
2513 push(@{$self->{param}{$param}},$value);
2514 next;
2515 }
2516
2517 my ($tmpfile,$tmp,$filehandle);
2518 UPLOADS: {
2519 # If we get here, then we are dealing with a potentially large
2520 # uploaded form. Save the data to a temporary file, then open
2521 # the file for reading.
2522
2523 # skip the file if uploads disabled
2524 if ($DISABLE_UPLOADS) {
2525 while (defined($data = $buffer->read)) { }
2526 last UPLOADS;
2527 }
2528
2529 # set the filename to some recognizable value
2530 if ( ( !defined($filename) || $filename eq '' ) && $multipart ) {
2531 $filename = "multipart/mixed";
2532 }
2533
2534 # choose a relatively unpredictable tmpfile sequence number
2535 my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
2536 for (my $cnt=10;$cnt>0;$cnt--) {
2537 next unless $tmpfile = new CGITempFile($seqno);
2538 $tmp = $tmpfile->as_string;
2539 last if defined($filehandle = Fh->new($filename,$tmp,$PRIVATE_TEMPFILES));
2540 $seqno += int rand(100);
2541 }
2542 die "CGI open of tmpfile: $!\n" unless defined $filehandle;
2543 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
2544 && defined fileno($filehandle);
2545
2546 # if this is an multipart/mixed attachment, save the header
2547 # together with the body for later parsing with an external
2548 # MIME parser module
2549 if ( $multipart ) {
2550 for ( keys %header ) {
2551 print $filehandle "$_: $header{$_}${CRLF}";
2552 }
2553 print $filehandle "${CRLF}";
2554 }
2555
2556 my ($data);
2557 local($\) = '';
2558 my $totalbytes = 0;
2559 while (defined($data = $buffer->read)) {
2560 if (defined $self->{'.upload_hook'})
2561 {
2562 $totalbytes += length($data);
2563 &{$self->{'.upload_hook'}}($filename ,$data, $totalbytes, $self->{'.upload_data'});
2564 }
2565 print $filehandle $data if ($self->{'use_tempfile'});
2566 }
2567
2568 # back up to beginning of file
2569 seek($filehandle,0,0);
2570
2571 ## Close the filehandle if requested this allows a multipart MIME
2572 ## upload to contain many files, and we won't die due to too many
2573 ## open file handles. The user can access the files using the hash
2574 ## below.
2575 close $filehandle if $CLOSE_UPLOAD_FILES;
2576 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
2577
2578 # Save some information about the uploaded file where we can get
2579 # at it later.
2580 # Use the typeglob as the key, as this is guaranteed to be
2581 # unique for each filehandle. Don't use the file descriptor as
2582 # this will be re-used for each filehandle if the
2583 # close_upload_files feature is used.
2584 $self->{'.tmpfiles'}->{$$filehandle}= {
2585 hndl => $filehandle,
2586 name => $tmpfile,
2587 info => {%header},
2588 };
2589 push(@{$self->{param}{$param}},$filehandle);
2590 }
2591 }
2592}
2593END_OF_FUNC
2594
2595#####
2596# subroutine: read_multipart_related
2597#
2598# Read multipart/related data and store it into our parameters. The
2599# first parameter sets the start of the data. The part identified by
2600# this Content-ID will not be stored as a file upload, but will be
2601# returned by this method. All other parts will be available as file
2602# uploads accessible by their Content-ID
2603#####
2604'read_multipart_related' => <<'END_OF_FUNC',
2605sub read_multipart_related {
2606 my($self,$start,$boundary,$length) = @_;
2607 my($buffer) = $self->new_MultipartBuffer($boundary,$length);
2608 return unless $buffer;
2609 my(%header,$body);
2610 my $filenumber = 0;
2611 my $returnvalue;
2612 while (!$buffer->eof) {
2613 %header = $buffer->readHeader;
2614
2615 unless (%header) {
2616 $self->cgi_error("400 Bad request (malformed multipart POST)");
2617 return;
2618 }
2619
2620 my($param) = $header{'Content-ID'}=~/\<([^\>]*)\>/;
2621 $param .= $TAINTED;
2622
2623 # If this is the start part, then just read the data and assign it
2624 # to our return variable.
2625 if ( $param eq $start ) {
2626 $returnvalue = $buffer->readBody;
2627 $returnvalue .= $TAINTED;
2628 next;
2629 }
2630
2631 # add this parameter to our list
2632 $self->add_parameter($param);
2633
2634 my ($tmpfile,$tmp,$filehandle);
2635 UPLOADS: {
2636 # If we get here, then we are dealing with a potentially large
2637 # uploaded form. Save the data to a temporary file, then open
2638 # the file for reading.
2639
2640 # skip the file if uploads disabled
2641 if ($DISABLE_UPLOADS) {
2642 while (defined($data = $buffer->read)) { }
2643 last UPLOADS;
2644 }
2645
2646 # choose a relatively unpredictable tmpfile sequence number
2647 my $seqno = unpack("%16C*",join('',localtime,grep {defined $_} values %ENV));
2648 for (my $cnt=10;$cnt>0;$cnt--) {
2649 next unless $tmpfile = new CGITempFile($seqno);
2650 $tmp = $tmpfile->as_string;
2651 last if defined($filehandle = Fh->new($param,$tmp,$PRIVATE_TEMPFILES));
2652 $seqno += int rand(100);
2653 }
2654 die "CGI open of tmpfile: $!\n" unless defined $filehandle;
2655 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode
2656 && defined fileno($filehandle);
2657
2658 my ($data);
2659 local($\) = '';
2660 my $totalbytes;
2661 while (defined($data = $buffer->read)) {
2662 if (defined $self->{'.upload_hook'})
2663 {
2664 $totalbytes += length($data);
2665 &{$self->{'.upload_hook'}}($param ,$data, $totalbytes, $self->{'.upload_data'});
2666 }
2667 print $filehandle $data if ($self->{'use_tempfile'});
2668 }
2669
2670 # back up to beginning of file
2671 seek($filehandle,0,0);
2672
2673 ## Close the filehandle if requested this allows a multipart MIME
2674 ## upload to contain many files, and we won't die due to too many
2675 ## open file handles. The user can access the files using the hash
2676 ## below.
2677 close $filehandle if $CLOSE_UPLOAD_FILES;
2678 $CGI::DefaultClass->binmode($filehandle) if $CGI::needs_binmode;
2679
2680 # Save some information about the uploaded file where we can get
2681 # at it later.
2682 # Use the typeglob as the key, as this is guaranteed to be
2683 # unique for each filehandle. Don't use the file descriptor as
2684 # this will be re-used for each filehandle if the
2685 # close_upload_files feature is used.
2686 $self->{'.tmpfiles'}->{$$filehandle}= {
2687 hndl => $filehandle,
2688 name => $tmpfile,
2689 info => {%header},
2690 };
2691 push(@{$self->{param}{$param}},$filehandle);
2692 }
2693 }
2694 return $returnvalue;
2695}
2696END_OF_FUNC
2697
2698
2699'upload' =><<'END_OF_FUNC',
2700sub upload {
2701 my($self,$param_name) = self_or_default(@_);
2702 my @param = grep {ref($_) && defined(fileno($_))} $self->param($param_name);
2703 return unless @param;
2704 return wantarray ? @param : $param[0];
2705}
2706END_OF_FUNC
2707
2708'tmpFileName' => <<'END_OF_FUNC',
2709sub tmpFileName {
2710 my($self,$filename) = self_or_default(@_);
2711 return $self->{'.tmpfiles'}->{$$filename}->{name} ?
2712 $self->{'.tmpfiles'}->{$$filename}->{name}->as_string
2713 : '';
2714}
2715END_OF_FUNC
2716
2717'uploadInfo' => <<'END_OF_FUNC',
2718sub uploadInfo {
2719 my($self,$filename) = self_or_default(@_);
2720 return $self->{'.tmpfiles'}->{$$filename}->{info};
2721}
2722END_OF_FUNC
2723
2724# internal routine, don't use
2725'_set_values_and_labels' => <<'END_OF_FUNC',
2726sub _set_values_and_labels {
2727 my $self = shift;
2728 my ($v,$l,$n) = @_;
2729 $$l = $v if ref($v) eq 'HASH' && !ref($$l);
2730 return $self->param($n) if !defined($v);
2731 return $v if !ref($v);
2732 return ref($v) eq 'HASH' ? keys %$v : @$v;
2733}
2734END_OF_FUNC
2735
2736# internal routine, don't use
2737'_set_attributes' => <<'END_OF_FUNC',
2738sub _set_attributes {
2739 my $self = shift;
2740 my($element, $attributes) = @_;
2741 return '' unless defined($attributes->{$element});
2742 $attribs = ' ';
2743 for my $attrib (keys %{$attributes->{$element}}) {
2744 (my $clean_attrib = $attrib) =~ s/^-//;
2745 $attribs .= "@{[lc($clean_attrib)]}=\"$attributes->{$element}{$attrib}\" ";
2746 }
2747 $attribs =~ s/ $//;
2748 return $attribs;
2749}
2750END_OF_FUNC
2751
2752'_compile_all' => <<'END_OF_FUNC',
2753sub _compile_all {
2754 for (@_) {
2755 next if defined(&$_);
2756 $AUTOLOAD = "CGI::$_";
2757 _compile();
2758 }
2759}
2760END_OF_FUNC
2761
2762);
2763
2764;